{-# LANGUAGE ViewPatterns               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  HMinCaml.Elim
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Useless let elimination.
--
--------------------------------------------------------------------------------

module HMinCaml.Elim
  (

    effect
  , elim

  ) where

import qualified HMinCaml.HMonad as H
import HMinCaml.KNormal


import Control.Applicative
import qualified Data.Set as S


effect :: Expr -> Bool
effect (Let _ e1 e2)            = effect e1 || effect e2
effect (IfEq _ _ e1 e2)         = effect e1 || effect e2 
effect (IfLE _ _ e1 e2)         = effect e1 || effect e2 
effect (LetRec _ e)             = effect e
effect (LetTuple _ _ e)         = effect e
effect (App {})                 = True
effect (Put {})                 = True
effect (ExtFunApp {})           = True
effect _                        = False


--------------------------------------------------------------------------------
-- Useless let elimination



type Mon a = H.HMonad a


elim :: Expr -> H.HMonad Expr
elim expr = em expr


em :: Expr -> Mon Expr
em (IfEq x y e1 e2)             = IfEq x y <$> em e1 <*> em e2
em (IfLE x y e1 e2)             = IfLE x y <$> em e1 <*> em e2
em (Let (x,t) e1 e2)            = 
    (\ea eb -> if effect ea || S.member x (freevars eb)
               then Let (x,t) ea eb else eb) 
      <$> em e1 <*> em e2

em (LetRec (Fundef (x,t) yts e1) e2) = 
    (\ea eb -> if S.member x (freevars eb) 
               then LetRec (Fundef (x,t) yts ea) eb else eb)
      <$> em e1 <*> em e2

em (LetTuple xts y e)           = 
    (\ea -> let xs   = map fst xts
                live = freevars ea
            in if any (S.member `flip` live) xs
               then LetTuple xts y ea else ea)
      <$> em e

em e                            = return e
